home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / 1svga / lookc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-29  |  4.8 KB  |  148 lines
  1. { Look Chn/Eng Text/1024x768,256 Colors }
  2.  
  3. uses Dos,SVGA256,Txt;
  4.  
  5. var Texts:array[0..15000] of ^string;
  6.     LineMax:integer;
  7.     DirInfo:SearchRec;
  8.     Dir:DirStr; Name:NameStr; Ext:ExtStr;
  9.     Font,FontAsc,FontSpc,FontSup:pointer;
  10.     FileChn:string;      { 12288,29376,26280 bytes }
  11.  
  12. { ─────────────── InitChinese ─────────────── }
  13. procedure InitChinese(Chn,Asc,Spc,Sup:string);
  14. begin
  15.   if (FileLen(Asc,1)<0) then
  16.     begin Writeln; Writeln(''''+Asc+''' not found !'); Halt(1); end;
  17.   if (FileLen(Spc,1)<0) then
  18.     begin Writeln; Writeln(''''+Spc+''' not found !'); Halt(1); end;
  19.   if (FileLen(Sup,1)<0) then
  20.     begin Writeln; Writeln(''''+Sup+''' not found !'); Halt(1); end;
  21.   FileChn:=Chn;
  22.   GetMem(FontAsc,12288); FileRead(Asc,0,256,48,FontAsc^);
  23.   GetMem(FontSpc,29376); FileRead(Spc,0,408,72,FontSpc^);
  24.   GetMem(FontSup,26280); FileRead(Sup,0,365,72,FontSup^);
  25. end;
  26. { ─────────────── PrintC ─────────────── }
  27. procedure PrintC(Ty,X,Y,Color,BkColor,Space,Count:integer;St:string);
  28. var Buf1,Buf2:array[0..575] of byte;    { Ty: 0=Mono, 1..4=Color }
  29.     S1,O1,S2,O2,S3,O3,I,Hi,Lo,N,L,P:integer;
  30.     C:word;
  31.     File1:file;
  32. begin
  33.   S1:=Seg(FontAsc^); O1:=Ofs(FontSpc^);
  34.   S2:=Seg(FontSpc^); O2:=Ofs(FontSpc^);
  35.   S3:=Seg(FontSup^); O3:=Ofs(FontSup^);
  36.   Assign(File1,FileChn); Reset(File1,72);
  37.   L:=Length(St); P:=0;
  38.   while P<L do begin
  39.     Hi:=Ord(St[P+1]); Lo:=Ord(St[P+2]); C:=Hi shl 8+Lo;
  40.     case C of
  41.       $A440..$C67E,$C940..$F9FE:begin
  42.     if Lo>$7E then Dec(Lo,34);
  43.     N:=157*(Hi-$A4)+Lo-$40;    if N>5400 then Dec(N,408);
  44.     if N<13094 then begin Seek(File1,N); BlockRead(File1,Buf1,1); end
  45.       else Move(Mem[S2:O2+6192],Buf1,72);
  46.     Conv1to8(Buf1,Buf2,72,Color,BkColor);
  47.     Hi:=24; Lo:=24+Space; N:=2;
  48.       end;
  49.       $A140..$A3BF:begin
  50.     if Lo>$7E then Dec(Lo,34);
  51.     N:=157*(Hi-$A1)+Lo-$40;
  52.     Conv1to8(Mem[S2:O2+72*N],Buf2,72,Color,BkColor);
  53.     Hi:=24; Lo:=24+Space; N:=2;
  54.       end;
  55.       $C6A1..$C8FE:begin
  56.     N:=157*(Hi-$C6)+Lo-$A1;
  57.     Conv1to8(Mem[S3:O3+72*N],Buf2,72,Color,BkColor);
  58.     Hi:=24; Lo:=24+Space; N:=2;
  59.       end else begin
  60.     Conv1to8(Mem[S1:O1+48*Hi],Buf2,48,Color,BkColor);
  61.     Hi:=16; Lo:=12+Space shr 1; N:=1;
  62.       end;
  63.     end;
  64.     if Ty>0 then Colorize(Ty,Hi,24,Color,Count,Color,Buf2);
  65.     Put(X,Y,Hi,24,Buf2);
  66.     Inc(X,Lo); Inc(P,N);
  67.   end;
  68.   Close(File1);
  69. end;
  70. { ─────────────── ReadTextFile ─────────────── }
  71. procedure ReadTextFile(Filename:string);
  72. var File1:text;
  73.     St:string;
  74.     I:integer;
  75. begin
  76.   Assign(File1,Filename); Reset(File1);
  77.   LineMax:=0;
  78.   while not Eof(File1) do begin
  79.     if (LineMax>15000) or (MemAvail<256) then begin Close(File1); Exit; end;
  80.     Readln(File1,St);
  81.     for I:=1 to 255 do if St[I]=#9 then
  82.       begin Delete(St,I,1); Insert('        ',St,I); end;
  83.     GetMem(Texts[LineMax],Length(St)+1);
  84.     Texts[LineMax]^:=St;
  85.     Inc(LineMax);
  86.   end;
  87.   Close(File1);
  88. end;
  89. { ─────────────── ShowPage ─────────────── }
  90. procedure ShowPage(X,Y:integer);
  91. var N,I,J:integer;
  92.     St:string[80];
  93. begin
  94.   if LineMax>23 then J:=23 else J:=LineMax;
  95.   for I:=0 to J-1 do begin
  96.     N:=Length(Texts[Y+I]^)-X;
  97.     if N<0 then N:=0; if N>80 then N:=80;
  98.     St[0]:=Chr(N); Move(Texts[Y+I]^[X+1],St[1],N);
  99.     PrintC(0,32,42+30*I,64+I shr 1,104,0,2,St);
  100.     Bar(32+12*N,42+30*I,12*(80-N),24,104);
  101.   end;
  102. end;
  103. { ─────────────── Look ─────────────── }
  104. procedure Look;
  105. var X,Y,K:integer;
  106.     St:string[5];
  107. begin
  108.   FSplit(ParamStr(1),Dir,Name,Ext);
  109.   ReadTextFile(Dir+DirInfo.Name);
  110.   Bar(0,0,1024,30,54); Bar(0,30,1024,708,104); Bar(0,738,1024,30,54);
  111.   PrintC(1,32,  3,63,54,0,2,'LookC V1.1   ññ¡^ñσÑ╗ñσ╛\┼¬╡{ªí   (C) 1994 '+
  112.     'Jou-Nan Chen');
  113.   PrintC(1,32,741,63,54,0,2,'í⌠í⌡-ñWñUªµ   í≈í÷-ѬÑkñGñQªr   '+
  114.     'PgUp,PgDn-ñWñU¡╢   Home,End-│╠½e,│╠½ß¡╢');
  115.   X:=0; Y:=0; K:=0;
  116.   repeat
  117.     Bar(808,3,200,24,54);
  118.     Str(X+1,St); PrintC(1,808,3,80,54,0,2,St);
  119.     Str(Y+1,St); PrintC(1,880,3,80,54,0,2,St);
  120.     if (K<>$2166) and (K<>$2146) then ShowPage(X,Y);
  121.     K:=Key;
  122.     case K of
  123.       $4800:Dec(Y);     $5000:Inc(Y);        { Up,Down }
  124.       $4900:Dec(Y,23);  $5100:Inc(Y,23);     { PgUp,PgDn }
  125.       $4B00:Dec(X,20);  $4D00:Inc(X,20);     { Left,Right }
  126.       $4700:begin X:=0; Y:=0; end;           { Home }
  127.       $4F00:begin X:=0; Y:=LineMax-23; end;  { End }
  128.     end;
  129.     if Y>=LineMax-23 then Y:=LineMax-23; if Y<0 then Y:=0;
  130.     if X>236 then X:=236; if X<0 then X:=0;
  131.   until K=$011B;    { Esc }
  132. end;
  133.  
  134. begin
  135.   if ParamCount=0 then
  136.     begin Writeln('Usage: Look Filename'); Halt(1); end;
  137.   if ParamCount=1 then begin
  138.     FindFirst(ParamStr(1),Archive,DirInfo);
  139.     if DosError<>0 then
  140.       begin Writeln('No such file !'); Halt(1); end;
  141.   end;
  142.   InitChinese('\et3\stdfont.24','\et3\ascfont.24','\et3\spcfont.24',
  143.     '\et3\spcfsupp.24');
  144.   if TestVESA=0 then
  145.     begin Writeln; Writeln('VESA driver not installed !'); Halt(1); end;
  146.   SetMode(5); Look; SetMode(0);
  147. end.
  148.